home *** CD-ROM | disk | FTP | other *** search
/ BBS Toolkit / BBS Toolkit.iso / doors_1 / multi604.zip / MONOMAIN.ZIP / DUREE.PAS next >
Pascal/Delphi Source File  |  1992-08-28  |  4KB  |  176 lines
  1. unit duree;
  2. interface
  3. uses dos;
  4. function cstr(t:longint):string;
  5. function timer:real;
  6. function nsl:real;
  7. function tch(t:string):string;
  8. function time:string;
  9. function days(mo,yr:integer):integer;
  10. function date:string;
  11. function leapyear(yr:integer):boolean;
  12. function daynum(dt:string):integer;
  13. function daycount(mo,yr:integer):integer;
  14. function dat:string;
  15. function ctim(rl:real):string;
  16. procedure calculheure(var heure,minute,seconde:integer);
  17.  
  18. implementation
  19.  
  20. var timeon,timeleft:real;
  21.     comport:byte;
  22.  
  23. function cstr(t:longint):string;
  24. var cu:string;
  25. begin
  26.      str(t,cu); cstr:=cu;
  27. end;
  28.  
  29. function timer:real;
  30. var reg:registers;
  31.     ho1,mi1,s3,t1:real;
  32. begin
  33.      reg.ax:=44*256;
  34.      msdos(dos.registers(reg));
  35.      ho1:=(reg.cx div 256);
  36.      mi1:=(reg.cx mod 256);
  37.      s3:=(reg.dx div 256);
  38.      t1:=(reg.dx mod 256);
  39.      timer:=ho1*3600+mi1*60+s3+t1/100;
  40. end;
  41.  
  42. function nsl:real;
  43. begin
  44.      if timer<timeon then timeon:=timeon-24.0*3600.0;
  45.      nsl:=timeleft-(timer-timeon);
  46. end;
  47.  
  48. function time:string;
  49. var reg:registers;
  50.     zt:integer;
  51.     ho1,mi1,se:string[4];
  52. begin
  53.      reg.ax:=$2c00; intr($21,dos.registers(reg));
  54.      zt:=reg.cx shr 8; ho1:=cstr(zt);
  55.      zt:=reg.cx mod 256; str(zt,mi1); str(reg.dx shr 8,se);
  56.      time:=tch(ho1)+':'+tch(mi1)+':'+tch(se);
  57. end;
  58.  
  59. function date:string;
  60. var reg:registers;
  61.     mi1,du,yx:string[4];
  62. begin
  63.      reg.ax:=$2a00; msdos(dos.registers(reg)); str(reg.cx,yx); str(reg.dx mod 256,du);
  64.      str(reg.dx shr 8,mi1);
  65.      date:=tch(mi1)+'/'+tch(du)+'/'+tch(yx);
  66. end;
  67.  
  68. function value(t:string):integer;
  69. var n,n1:integer;
  70. begin
  71.      val(t,n,n1);
  72.      if n1<>0 then begin
  73.         t:=copy(t,1,n1-1);
  74.         val(t,n,n1)
  75.      end;
  76.      value:=n;
  77.      if t='' then value:=0;
  78. end;
  79.  
  80. procedure calculheure(var heure,minute,seconde:integer);
  81. begin
  82.      heure:=value(copy(time,1,2));
  83.      minute:=value(copy(time,4,2));
  84.      seconde:=value(copy(time,7,2));
  85. end;
  86.  
  87. function leapyear(yr:integer):boolean;
  88. begin
  89.      leapyear:=(yr mod 4=0) and ((yr mod 100<>0) or (yr mod 400=0));
  90. end;
  91.  
  92. function days(mo,yr:integer):integer;
  93. var du:integer;
  94. begin
  95.      du:=value(copy('312831303130313130313031 ',1+(mo-1)*2,2));
  96.      if (mo=2) and leapyear(yr) then du:=du+1;
  97.      days:=du;
  98. end;
  99.  
  100. function daycount(mo,yr:integer):integer;
  101. var mi1,tu:integer;
  102. begin
  103.      tu:=0;
  104.      for mi1:=1 to (mo-1) do tu:=tu+days(mi1,yr);
  105.      daycount:=tu;
  106. end;
  107.  
  108. function tch(t:string):string;
  109. begin
  110.      if length(t)>2 then t:=copy(t,length(t)-1,2) else
  111.         if length(t)=1 then t:='0'+t;
  112.      tch:=t;
  113. end;
  114.  
  115.  
  116.  
  117. function daynum(dt:string):integer;
  118. var du,mi1,yx,tu,cu:integer;
  119. begin
  120.      tu:=0;
  121.      mi1:= value(copy(dt,1,2));
  122.      du:=value(copy(dt,4,2));
  123.      yx:=value(copy(dt,7,2))+1900;
  124.      for cu:=1985 to yx-1 do
  125.          if leapyear(cu) then tu:=tu+366 else tu:=tu+365;
  126.      tu:=tu+daycount(mi1,yx)+(du-1);
  127.      daynum:=tu;
  128.      if yx<1985 then daynum:=0;
  129. end;
  130.  
  131. function dat:string;
  132. var ap,xy,yx:string; t:integer;
  133. begin
  134.      case daynum(date) mod 7 of
  135.           0:xy:='Tue';
  136.           1:xy:='Wed';
  137.           2:xy:='Thu';
  138.           3:xy:='Fri';
  139.           4:xy:='Sat';
  140.           5:xy:='Sun';
  141.           6:xy:='Mon';
  142.      end;
  143.      case value(copy(date,1,2)) of
  144.           1:yx:='Jan';
  145.           2:yx:='Feb';
  146.           3:yx:='Mar';
  147.           4:yx:='Apr';
  148.           5:yx:='May';
  149.           6:yx:='Jun';
  150.           7:yx:='Jul';
  151.           8:yx:='Aug';
  152.           9:yx:='Sep';
  153.           10:yx:='Oct';
  154.           11:yx:='Nov';
  155.           12:yx:='Dec';
  156.      end;
  157.      xy:=xy+' '+yx+' '+copy(date,4,2)+', '+cstr(1900+value(copy(date,7,2)));
  158.      yx:=time; t:=value(copy(yx,1,2));
  159.      if t>11 then ap:='pm' else ap:='am';
  160.      if t>12 then t:=t-12;
  161.      if t=0 then t:=12;
  162.      dat:=cstr(t)+copy(yx,3,3)+' '+ap+' '+xy;
  163. end;
  164.  
  165.  
  166. function ctim(rl:real):string;
  167. var ho1,mi1,se:string;
  168. begin
  169.      se:=tch(cstr(trunc(rl-int(rl/60.0)*60.0)));
  170.      mi1:=tch(cstr(trunc(int(rl/60.0)-int(rl/3600.0)*60.0)));
  171.      ho1:=cstr(trunc(rl/3600.0));
  172.      if length(ho1)=1 then ho1:='0'+ho1;
  173.      ctim:=ho1+':'+mi1+':'+se;
  174. end;
  175.  
  176. end.